PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/mee/vbdao/visdata/query.frm

Visual Basic Form | 1994-10-06 | 18.2 KB | 614 lines

VERSION 2.00
Begin Form fQuery
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Query Builder"
   ClientHeight    =   5130
   ClientLeft      =   1230
   ClientTop       =   1155
   ClientWidth     =   7095
   ControlBox      =   0   'False
   Height          =   5535
   Icon            =   0
   Left            =   1170
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   ScaleHeight     =   5112
   ScaleMode       =   0  'User
   ScaleWidth      =   7116
   Top             =   810
   Width           =   7215
   Begin PictureBox ExpressionBox
      BackColor       =   &H00C0C0C0&
      Height          =   1092
      Left            =   120
      ScaleHeight     =   1065
      ScaleWidth      =   6825
      TabIndex        =   17
      Tag             =   "OLS"
      Top             =   120
      Width           =   6852
      Begin CommandButton GetValuesButton
         Caption         =   "List Possible &Values"
         Height          =   252
         Left            =   4200
         TabIndex        =   23
         Top             =   720
         Width           =   2292
      End
      Begin ComboBox cValue
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   4080
         Sorted          =   -1  'True
         TabIndex        =   22
         Tag             =   "POLS"
         Text            =   "cValue"
         Top             =   360
         Width           =   2652
      End
      Begin ComboBox cOperator
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   2880
         Style           =   2  'Dropdown List
         TabIndex        =   21
         Tag             =   "POLS"
         Top             =   360
         Width           =   1092
      End
      Begin ComboBox cField
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   120
         Style           =   2  'Dropdown List
         TabIndex        =   20
         Tag             =   "POLS"
         Top             =   360
         Width           =   2652
      End
      Begin CommandButton ORButton
         Caption         =   "&Or into Criteria"
         Height          =   252
         Left            =   2040
         TabIndex        =   19
         Top             =   720
         Width           =   1812
      End
      Begin CommandButton ANDButton
         Caption         =   "&And into Criteria"
         Height          =   252
         Left            =   120
         TabIndex        =   18
         Top             =   720
         Width           =   1812
      End
      Begin Label OperatorLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Operator:"
         Height          =   192
         Left            =   2880
         TabIndex        =   26
         Top             =   120
         Width           =   972
      End
      Begin Label ValueLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Value:"
         Height          =   192
         Left            =   4080
         TabIndex        =   25
         Top             =   120
         Width           =   1452
      End
      Begin Label FieldNameLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Field Name:"
         Height          =   192
         Left            =   120
         TabIndex        =   24
         Top             =   120
         Width           =   1332
      End
   End
   Begin CommandButton JoinButton
      Caption         =   "Set Table &Joins"
      Height          =   255
      Left            =   4440
      TabIndex        =   16
      Top             =   2520
      Width           =   2535
   End
   Begin ListBox cJoinFields
      BackColor       =   &H00FFFFFF&
      Height          =   420
      Left            =   4440
      TabIndex        =   15
      Tag             =   "OLS"
      Top             =   2760
      Width           =   2535
   End
   Begin CommandButton CopySQLButton
      Caption         =   "&Copy SQL"
      Height          =   375
      Left            =   3000
      TabIndex        =   14
      Top             =   4680
      Width           =   1095
   End
   Begin ComboBox cOrderByField
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   4440
      Style           =   2  'Dropdown List
      TabIndex        =   12
      Tag             =   "OLS"
      Top             =   2160
      Width           =   2535
   End
   Begin ComboBox cGroupByField
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   4440
      Style           =   2  'Dropdown List
      TabIndex        =   10
      Tag             =   "OLS"
      Top             =   1560
      Width           =   2535
   End
   Begin ListBox cTableList
      BackColor       =   &H00FFFFFF&
      Height          =   1590
      Left            =   120
      MultiSelect     =   1  'Simple
      TabIndex        =   9
      Tag             =   "OLS"
      Top             =   1560
      Width           =   1815
   End
   Begin CommandButton ShowSQLButton
      Caption         =   "&Show SQL"
      Height          =   375
      Left            =   1680
      TabIndex        =   8
      Top             =   4680
      Width           =   1095
   End
   Begin ListBox cShowFields
      BackColor       =   &H00FFFFFF&
      Height          =   1590
      Left            =   2040
      MultiSelect     =   1  'Simple
      TabIndex        =   5
      Tag             =   "OLS"
      Top             =   1560
      Width           =   2295
   End
   Begin CommandButton CloseButton
      Cancel          =   -1  'True
      Caption         =   "Close"
      Height          =   375
      Left            =   5640
      TabIndex        =   2
      Top             =   4680
      Width           =   1095
   End
   Begin CommandButton RunQueryButton
      Caption         =   "&Run Query"
      Height          =   375
      Left            =   360
      TabIndex        =   1
      Top             =   4680
      Width           =   1095
   End
   Begin CommandButton ClearButton
      Caption         =   "C&lear All"
      Height          =   375
      Left            =   4320
      TabIndex        =   0
      Top             =   4680
      Width           =   1095
   End
   Begin TextBox cCriteria
      BackColor       =   &H00FFFFFF&
      Height          =   1215
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   3
      Tag             =   "OLS"
      Top             =   3360
      Width           =   6855
   End
   Begin Label OrberByFieldLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Order By Field:"
      Height          =   192
      Left            =   4440
      TabIndex        =   13
      Top             =   1920
      Width           =   2055
   End
   Begin Label GroupByFieldLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Group By Field:"
      Height          =   192
      Left            =   4440
      TabIndex        =   11
      Top             =   1320
      Width           =   2055
   End
   Begin Label TableListLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Select Tables:"
      Height          =   192
      Left            =   120
      TabIndex        =   7
      Top             =   1320
      Width           =   1455
   End
   Begin Label ShowFieldsLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Select Fields to Show:"
      Height          =   195
      Left            =   2040
      TabIndex        =   6
      Top             =   1320
      Width           =   2055
   End
   Begin Label CriteriaLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Criteria:"
      Height          =   180
      Left            =   120
      TabIndex        =   4
      Top             =   3150
      Width           =   1335
   End
Dim FShowSQL As Integer
Dim FCopySQL As Integer
Sub ANDButton_Click ()
  Dim typ As Integer
  Dim fn As String
  Dim tb As String
  If Len(cField) = 0 Then Exit Sub
  tb = stSTF((cField), 0)
  fn = stSTF((cField), 1)
  typ = gCurrentDB.TableDefs(StripBrackets(tb)).Fields(StripBrackets(fn)).Type
  If Len(cCriteria) > 0 Then
    cCriteria = cCriteria & CRLF & "And "
  End If
  If typ = FT_STRING Or typ = FT_MEMO Or typ = FT_DATETIME Then
    cCriteria = cCriteria + cField & " " & cOperator & " '" & cValue & "'"
  Else
    cCriteria = cCriteria + cField & " " & cOperator & " " & cValue
  End If
  cField.SetFocus
End Sub
Sub cField_Click ()
  cValue.Clear
End Sub
Sub ClearButton_Click ()
  cCriteria = NULL_STR
End Sub
Sub CloseButton_Click ()
  Unload Me
End Sub
Sub CopySQLButton_Click ()
  FCopySQL = True
  Call RunQueryButton_Click
  FCopySQL = False
End Sub
Sub cTableList_Click ()
  Dim i As Integer, ii As Integer
  Dim t As TableDef
  Dim st As String
  MsgBar "Updating Form Fields", True
  cField.Clear
  cShowFields.Clear
  cGroupByField.Clear
  cOrderByField.Clear
  cValue.Clear
  cGroupByField.AddItem "(none)"
  cOrderByField.AddItem "(none)"
  For ii = 0 To cTableList.ListCount - 1
    If cTableList.Selected(ii) Then
      Set t = gCurrentDB.TableDefs(cTableList.List(ii))
      For i = 0 To t.Fields.Count - 1
        st = AddBrackets((cTableList.List(ii))) & "." & AddBrackets((t.Fields(i).Name))
        cField.AddItem st
        cShowFields.AddItem st
        cGroupByField.AddItem st
        cOrderByField.AddItem st
      Next
    End If
  Next
  If Len(cField.List(0)) > 0 Then
    cField.ListIndex = 0
    cGroupByField.ListIndex = 0
    cOrderByField.ListIndex = 0
  End If
  MsgBar NULL_STR, False
End Sub
Sub Form_Load ()
   On Local Error GoTo FLErr
   Dim ds As Dynaset
   Dim i As Integer
   Dim t As TableDef
   'Clear listbox
   cCriteria = NULL_STR
   'Fill the Operator combo
   cOperator.AddItem "="
   cOperator.AddItem "<>"
   cOperator.AddItem ">"
   cOperator.AddItem ">="
   cOperator.AddItem "<"
   cOperator.AddItem "<="
   cOperator.AddItem "Like"
   cOperator.ListIndex = 0
   'fill the table list
   For i = 0 To fTables.cTableList.ListCount - 1
     cTableList.AddItem StripOwner((fTables.cTableList.List(i)))
   Next
   cTableList.ListIndex = 0
   cValue = NULL_STR
  GoTo FLEnd
FLErr:
  ShowError
  Resume FLEnd
FLEnd:
  Height = 5520
  Width = 7224
  Left = (VDMDI.Width - Width) / 2
  Top = 0
End Sub
Sub Form_Paint ()
  Outlines Me
  PicOutlines ExpressionBox, cField
  PicOutlines ExpressionBox, cOperator
  PicOutlines ExpressionBox, cValue
End Sub
Sub Form_Resize ()
  On Error Resume Next
  If WindowState <> 1 Then
    Height = 5520
    Width = 7224
  End If
End Sub
Sub GetValuesButton_Click ()
  Dim ds As Dynaset
  On Error GoTo GVErr
  MsgBar "Getting Possible Values", True
  SetHourglass Me
  Set ds = gCurrentDB.CreateDynaset("select Distinct " & cField & " from " & stSTF((cField), 0))
  Do While ds.EOF = False
    If Len(Trim(ds(0))) > 0 Then
      cValue.AddItem ds(0).Value
    End If
    ds.MoveNext
  Loop
  ds.Close
  cValue.AddItem "_P1_"
  cValue.AddItem "_P2_"
  cValue.AddItem "_P3_"
  cValue.AddItem "_P4_"
  cValue = cValue.List(0)
  cValue.SetFocus
  GoTo GVEnd
GVErr:
  cValue = NULL_STR
  Resume GVEnd
GVEnd:
  ResetMouse Me
  MsgBar NULL_STR, False
End Sub
Sub JoinButton_Click ()
  Dim i As Integer
  Dim c As Integer
  For i = 0 To cTableList.ListCount - 1
    If cTableList.Selected(i) = True Then
      c = c + 1
    End If
  Next
  If c < 2 Then
    Beep
    MsgBox "You Must Have at Least 2 Tables Selected!", 48
  Else
    MsgBar "Choose Joins", False
    fJoin.Show MODAL
    MsgBar NULL_STR, False
  End If
End Sub
Sub ORButton_Click ()
  Dim typ As Integer
  Dim fn As String
  Dim tb As String
  If Len(cField) = 0 Then Exit Sub
  tb = stSTF((cField), 0)
  fn = stSTF((cField), 1)
  typ = gCurrentDB.TableDefs(StripBrackets(tb)).Fields(StripBrackets(fn)).Type
  If Len(cCriteria) > 0 Then
    cCriteria = cCriteria & CRLF & " Or "
  End If
  If typ = FT_STRING Or typ = FT_MEMO Or typ = FT_DATETIME Then
    cCriteria = cCriteria + cField & " " & cOperator & " '" & cValue & "'"
  Else
    cCriteria = cCriteria + cField & " " & cOperator & " " & cValue
  End If
  cField.SetFocus
End Sub
Sub RunQueryButton_Click ()
  On Error GoTo okerr
     Dim ds As Dynaset
     Dim fs As String
     Dim ts As String
     Dim i As Integer
    MsgBar "Building Query", True
     If Len(cCriteria) > 0 Then
       stWhere$ = "AND " & LTrim(cCriteria)
       'strip CRLFs
       For i = 1 To Len(stWhere$)
         If Mid(stWhere$, i, 1) = Chr$(13) Then
           stTmp$ = stTmp$ & " "
         ElseIf Mid(stWhere$, i, 1) = Chr$(10) Then
           'do nothing
         Else
           stTmp$ = stTmp$ + Mid(stWhere$, i, 1)
         End If
       Next
       stWhere$ = stTmp$
       stWhere$ = RTrim(stWhere$)

       'Add parens to stWhere$
        stTmpWhere$ = stWhere$
        Do
          stTmp$ = stGetToken(stTmpWhere$, " ")
          stTmp$ = stTmp$ & " "
           If fMatchParen% = False And UCase(stTmp$) = "AND " Then
            stNewWhere$ = stNewWhere$ + stTmp$ & "("
            fMatchParen% = True
          ElseIf fMatchParen% = True And UCase(stTmp$) = "AND " Then
            stNewWhere$ = stNewWhere$ & ") " & stTmp$ & "("
            'fMatchParen% = False
          Else
            If UCase(stTmp$) = "OR" Or UCase(stTmp$) = "IN " Or UCase(stTmp$) = "LIKE" Then
              stNewWhere$ = stNewWhere$ & " " & stTmp$
            Else
              stNewWhere$ = stNewWhere$ + stTmp$
            End If
          End If
        Loop Until stTmpWhere$ = NULL_STR
        stWhere$ = stNewWhere$ & ")"
       'Build DynaSet string:
       'Peel off leading AND/OR
       If Mid(stWhere$, 2, 2) = "OR" Then
         stWhere$ = Mid(stWhere$, 5, Len(stWhere$) - 5)
       Else
         stTmp$ = stGetToken(stWhere$, " ")
       End If
       If Len(stWhere$) > 0 Then
         stWhere$ = " Where " & stWhere$
       End If
     End If
     'check for join condition
     If cJoinFields.ListCount > 0 Then
       If Len(stWhere$) = 0 Then
         stWhere$ = stWhere$ & " Where "
       Else
         stWhere$ = stWhere$ & " And "
       End If
       For i = 0 To cJoinFields.ListCount - 1
         stWhere$ = stWhere$ + cJoinFields.List(i) & " And "
       Next
       stWhere$ = Mid(stWhere$, 1, Len(stWhere$) - 5)
     End If

     'check for group by field
     If cGroupByField <> "(none)" Then
       stWhere$ = stWhere$ & " Group By " & cGroupByField
     End If
     'check for order by field
     If cOrderByField <> "(none)" Then
       stWhere$ = stWhere$ & " Order By " & cOrderByField
     End If
     'get show field names
     For i% = 0 To cShowFields.ListCount - 1
       If cShowFields.Selected(i%) Then
         fs = fs + cShowFields.List(i%) & ","
       End If
     Next
     If Len(fs) = 0 Then
       For i% = 0 To cTableList.ListCount - 1
         If cTableList.Selected(i%) Then
           fs = fs + AddBrackets((cTableList.List(i%))) & ".*,"
         End If
       Next
       If Len(fs) = 0 Then
         fs = "*"
       Else
         fs = Mid(fs, 1, Len(fs) - 1)     'take off the last ","
       End If
     Else
       fs = Mid(fs, 1, Len(fs) - 1)
     End If
     'get table names
     For i% = 0 To cTableList.ListCount - 1
       If cTableList.Selected(i%) Then
         ts = ts + AddBrackets((cTableList.List(i%))) & ","
       End If
     Next
     ts = Mid(ts, 1, Len(ts) - 1)
     gstDynaString = "Select " & fs & " From " & ts + stWhere$

     If FShowSQL = False And FCopySQL = False Then
       MsgBar "Running Query", True
       gfFromSQL = True
       'create a new dynaset form
       If VDMDI.cSingleRecord = True Then
         Dim dsform1 As New fDynaset
         dsform1.Show
       Else
         Dim dsform2 As New fGridFrm
         dsform2.Show
       End If
     ElseIf FShowSQL = True Then
       MsgBar NULL_STR, False
       MsgBox gstDynaString, 0, "SQL Query"
     ElseIf FCopySQL = True Then
       fSQL.cSQLStatement = gstDynaString
     End If
  GoTo OKEnd
okerr:
  If Err = 364 Then Resume OKEnd   'catch unloaded form
  ShowError
  Resume OKEnd
OKEnd:
  MsgBar NULL_STR, False
End Sub
Sub ShowSQLButton_Click ()
  FShowSQL = True
  Call RunQueryButton_Click
  FShowSQL = False
End Sub
Function stGetToken (stLn$, stDelim$) As String
    On Error GoTo GetTokenError
    iOpenQuote% = InStr(1, stLn$, """")
    iDelim% = InStr(1, stLn$, stDelim$)
    If (iOpenQuote% > 0) And (iOpenQuote% < iDelim%) Then
         iCloseQuote% = InStr(iOpenQuote% + 1, stLn$, """")
         iDelim% = InStr(iCloseQuote% + 1, stLn$, stDelim$)
    End If
    If (iDelim% <> 0) Then
         stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1, iDelim% - 1)))
         stLn$ = Mid$(stLn$, iDelim% + 1)
    Else
         stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1)))
         stLn$ = NULL_STR
    End If
    If (Len(stToken$) > 0) Then
         If (Mid$(stToken$, 1, 1) = """") Then
              stToken$ = Mid$(stToken$, 2)
         End If
         If (Mid$(stToken$, Len(stToken$), 1) = """") Then
              stToken$ = Mid$(stToken$, 1, Len(stToken$) - 1)
         End If
    End If
    stGetToken = stToken$
GetTokenExit:
    Exit Function
GetTokenError:
    Resume GetTokenExit
End Function
'function to split the table and the field from a tbl.fld pair
Function stSTF (tf As String, part As Integer) As String
  If InStr(InStr(1, tf, ".") + 1, tf, ".") > 1 Then
    tf = StripOwner(tf)
  End If
  If part = 0 Then
    stSTF = Mid(tf, 1, InStr(1, tf, ".") - 1)
  Else
    stSTF = Mid(tf, InStr(1, tf, ".") + 1, Len(tf))
  End If
End Function